home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / defappleevents / defappleeevents.Lisp next >
Encoding:
Text File  |  1994-09-12  |  30.9 KB  |  823 lines  |  [TEXT/CCL2]
  1. ;; -*-Mode: LISP; Package: DEFAPPLEEVENTS; Base: 10; Syntax: Common-lisp -*-
  2. ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  3. ;;
  4. ;; defappleevents -- high level access to appleevent records
  5. ;;
  6. ;; Author: Ray Pelletier
  7. ;;         pelletier@cmu.edu
  8. ;;
  9.  
  10. (defpackage "DEFAPPLEEVENTS"
  11.   (:export "DEFAPPLEEVENT"
  12.            "GET-APPLEEVENT-ATTRIBUTE"
  13.            "GET-APPLEEVENT-ATTRIBUTE-AEDESC"
  14.            "PUT-APPLEEVENT-ATTRIBUTE"
  15.            "GET-APPLEEVENT-PARAMETER"
  16.            "GET-APPLEEVENT-PARAMETER-AEDESC"
  17.            "PUT-APPLEEVENT-PARAMETER"
  18.            "PUT-APPLEEVENT-OPTIONAL-PARAMETER"))
  19.  
  20. (in-package "DEFAPPLEEVENTS")
  21.  
  22. ;;
  23. ;;(defappleevent <name> <aeclass> <aeid> (<aeparameter>*) (<aeattribute>*))
  24. ;;
  25. ;;   <aeparameter> :== (<name> <key> {:desired-type <key>} {:optional t/nil})
  26. ;;   <aeattribute> :== (<name> <key> {:desired-type <key>})
  27. ;;
  28.  
  29. ;structures used by defappleevent macro-expander
  30. ;
  31. (defstruct parsed-defapplevent
  32.   name
  33.   class
  34.   id
  35.   parameters
  36.   attributes)
  37.  
  38. (defstruct name-key name key)
  39.  
  40. (defstruct (parsed-attribute (:include name-key))
  41.   (desired-type #$typeWildCard))
  42.  
  43. (defstruct (parsed-parameter (:include name-key))
  44.   (desired-type #$typeWildCard)
  45.   optional)
  46.  
  47. ;(defvar *appleevent-parsings* (make-hash-table))
  48.  
  49. (defvar *collapse-primitive-descriptors* t)
  50. ;if non-nil we translate descriptors into lisp types when possible
  51.  
  52. ;;
  53. (defmacro defappleevent (name class id parameters attributes)
  54.   (let ((params  (mapcar #'(lambda (x) (parse-parameter x)) parameters))
  55.         (attribs (mapcar #'(lambda (x) (parse-attribute x)) attributes)))
  56.     (let* ((a-d (make-parsed-defapplevent
  57.                  :name       name
  58.                  :class      (symbol-value class)
  59.                  :id         (symbol-value id)
  60.                  :parameters params
  61.                  :attributes attribs)))
  62.       `(progn
  63.          ,(compose-appleevent-constructor a-d)
  64.          ,(compose-appleevent-predicate a-d)
  65.          ,@(compose-appleevent-accessors a-d)
  66.          ',name))))
  67.  
  68. ;; fns used to expand DEFAPPLEEVENT
  69. ;;
  70. (defun parse-attribute (attribute)
  71.   (apply #'make-parsed-attribute
  72.          :name (first attribute)
  73.          :key  (second attribute)
  74.          (cddr attribute)))
  75.  
  76. (defun parse-parameter (parameter)
  77.   (apply #'make-parsed-parameter
  78.          :name (first parameter)
  79.          :key  (second parameter)
  80.          (cddr parameter)))
  81.  
  82. (defun compose-appleevent-constructor (a-d)
  83.   (let ((constructor-name (intern (concatenate 'string
  84.                                                "MAKE-"
  85.                                                (string (parsed-defapplevent-name a-d)))))
  86.         (target-holder    (gentemp "TARGET"))
  87.         (aevent-holder    (gentemp "AEVT"))
  88.         (aedesc-holder    (gentemp "ADDRESS-DESC"))
  89.         (paramkeyspecs    (mapcar #'compose-keyspecs (parsed-defapplevent-parameters a-d)))
  90.         (attribkeyspecs   (mapcar #'compose-keyspecs (parsed-defapplevent-attributes a-d))))
  91.     (let ((param-setters 
  92.            (mapcar #'(lambda (key param)
  93.                        (compose-param-initializer aevent-holder key param))
  94.                    paramkeyspecs
  95.                    (parsed-defapplevent-parameters a-d)))
  96.           (attrib-setters 
  97.            (mapcar #'(lambda (key attrib)
  98.                        (compose-attrib-initializer aevent-holder key attrib))
  99.                    attribkeyspecs
  100.                    (parsed-defapplevent-attributes a-d))))
  101.       
  102.       `(defun ,constructor-name (,aevent-holder ,target-holder &key
  103.                                                 (return-id #$kAutoGenerateReturnID)
  104.                                                 (transaction-id #$kAnyTransactionID)
  105.                                                 ,@paramkeyspecs ,@attribkeyspecs)
  106.          (with-aedescs (,aedesc-holder)
  107.            (ae-error (#_AECreateAppleEvent
  108.                       ,(parsed-defapplevent-class a-d)
  109.                       ,(parsed-defapplevent-id a-d)
  110.                       (if (macptrp ,target-holder)
  111.                         ,target-holder
  112.                         (lisp->aedesc ,target-holder ,aedesc-holder))
  113.                       return-id
  114.                       transaction-id
  115.                       ,aevent-holder)))
  116.          ,@param-setters
  117.          ,@attrib-setters
  118.          ,aevent-holder))))
  119.  
  120. (defun compose-keyspecs (name-key)
  121.   (let* ((name (name-key-name name-key))
  122.          (present (intern (concatenate 'string (symbol-name name) "-PRESENT-P"))))
  123.     (when (keywordp name)
  124.       (setf name (intern (symbol-name name))))
  125.     `(,name nil ,present)))
  126.  
  127. (defun compose-attrib-initializer (aevent-holder keyspec attrib)
  128.   `(when ,(third keyspec)
  129.      (put-appleevent-attribute
  130.       ,aevent-holder
  131.       ,(parsed-attribute-key attrib)
  132.       ,(first keyspec))))
  133.  
  134. (defun compose-param-initializer (aevent-holder keyspec attrib)
  135.   `(when ,(third keyspec)
  136.      (,(if (parsed-parameter-optional attrib)
  137.          'put-appleevent-optional-parameter
  138.          'put-appleevent-parameter)
  139.       ,aevent-holder
  140.       ,(parsed-parameter-key attrib)
  141.       ,(first keyspec))))
  142. ;;
  143. (defun compose-appleevent-predicate (a-d)
  144.   (let ((aevent-holder (gentemp "AEVENT"))
  145.         (predicate-name (intern (concatenate 'string
  146.                                              (string (parsed-defapplevent-name a-d))
  147.                                              "-P"))))
  148.     `(defun ,predicate-name (,aevent-holder)
  149.        (let ((*collapse-primitive-descriptors* t))
  150.          (and (eql ,(parsed-defapplevent-class a-d)
  151.                    (get-appleevent-attribute ,aevent-holder #$keyEventClassAttr #$typekeyWord))
  152.               (eql ,(parsed-defapplevent-id a-d)
  153.                    (get-appleevent-attribute ,aevent-holder #$keyEventIdAttr #$typekeyWord)))))))
  154.  
  155. ;;
  156. (defun compose-appleevent-accessors (a-d)
  157.   (let ((name (parsed-defapplevent-name a-d)))
  158.     (nconc
  159.      (mapcar #'(lambda (a) (compose-attribute-reader name a))
  160.              (parsed-defapplevent-attributes a-d))
  161.      (mapcar #'(lambda (a) (compose-attribute-aedesc-reader name a))
  162.              (parsed-defapplevent-attributes a-d))
  163.      (mapcar #'(lambda (a) (compose-attribute-writer name a))
  164.              (parsed-defapplevent-attributes a-d))
  165.      (mapcar #'(lambda (p) (compose-parameter-reader name p))
  166.              (parsed-defapplevent-parameters a-d))
  167.      (mapcar #'(lambda (p) (compose-parameter-aedesc-reader name p))
  168.              (parsed-defapplevent-parameters a-d))
  169.      (mapcar #'(lambda (p) (compose-parameter-writer name p))
  170.              (parsed-defapplevent-parameters a-d)))))
  171.  
  172. (defun compose-attribute-reader (name attribute)
  173.   (let ((aeholder    (gentemp "AEVENT"))
  174.         (reader-name (intern (concatenate 'string
  175.                                           (string name)
  176.                                           "-"
  177.                                           (string (parsed-attribute-name attribute))))))
  178.     `(defun ,reader-name (,aeholder)
  179.        (get-appleevent-attribute 
  180.         ,aeholder
  181.         ,(parsed-attribute-key attribute)
  182.         ,(parsed-attribute-desired-type attribute)))))
  183.  
  184. (defun compose-attribute-aedesc-reader (name attribute)
  185.   (let ((aeholder    (gentemp "AEVENT"))
  186.         (descholder  (gentemp "AEDESC"))
  187.         (reader-name (intern (concatenate 'string
  188.                                           (string name)
  189.                                           "-"
  190.                                           (string (parsed-attribute-name attribute))
  191.                                           "-AEDESC"))))
  192.     `(defun ,reader-name (,descholder ,aeholder)
  193.        (get-appleevent-attribute-aedesc
  194.         ,aeholder
  195.         ,(parsed-attribute-key attribute)
  196.         ,(parsed-attribute-desired-type attribute)
  197.         ,descholder))))
  198.  
  199. (defun compose-attribute-writer (name attribute)
  200.   (let ((aeholder    (gentemp "AEVENT"))
  201.         (dataholder  (gentemp "DATA"))
  202.         (reader-name (intern (concatenate 'string
  203.                                           (string name)
  204.                                           "-"
  205.                                           (string (parsed-attribute-name attribute))))))
  206.     `(defun (setf ,reader-name) (,dataholder ,aeholder)
  207.        (put-appleevent-attribute
  208.         ,aeholder
  209.         ,(parsed-attribute-key attribute)
  210.         ,dataholder))))
  211.  
  212. (defun compose-parameter-reader (name parameter)
  213.   (let ((aeholder    (gentemp "AEVENT"))
  214.         (reader-name (intern (concatenate 'string
  215.                                           (string name)
  216.                                           "-"
  217.                                           (string (parsed-parameter-name parameter))))))
  218.     `(defun ,reader-name (,aeholder)
  219.        (get-appleevent-parameter
  220.         ,aeholder
  221.         ,(parsed-parameter-key parameter)
  222.         ,(parsed-parameter-desired-type parameter)))))
  223.  
  224. (defun compose-parameter-aedesc-reader (name parameter)
  225.   (let ((aeholder    (gentemp "AEVENT"))
  226.         (descholder  (gentemp "AEDESC"))
  227.         (reader-name (intern (concatenate 'string
  228.                                           (string name)
  229.                                           "-"
  230.                                           (string (parsed-parameter-name parameter))
  231.                                           "-AEDESC"))))
  232.     `(defun ,reader-name (,aeholder ,descholder)
  233.        (get-appleevent-parameter-aedesc
  234.         ,aeholder
  235.         ,(parsed-parameter-key parameter)
  236.         ,(parsed-parameter-desired-type parameter)
  237.         ,descholder))))
  238.  
  239. (defun compose-parameter-writer (name parameter)
  240.   (let ((aeholder    (gentemp "AEVENT"))
  241.         (dataholder  (gentemp "DATA"))
  242.         (reader-name (intern (concatenate 'string
  243.                                           (string name)
  244.                                           "-"
  245.                                           (string (parsed-parameter-name parameter))
  246.                                           "-AEDESC"))))
  247.     `(defun (setf ,reader-name) (,dataholder ,aeholder)
  248.        (,(if (parsed-parameter-optional parameter)
  249.            'put-appleevent-optional-parameter
  250.            'put-appleevent-parameter)
  251.         ,aeholder
  252.         ,(parsed-parameter-key parameter)
  253.         ,dataholder))))
  254.  
  255. ;;
  256. ;; access performed by these guys
  257. ;;
  258. (defun get-appleevent-attribute (aevent attr-key desired-type)
  259.   (let ((type)
  260.         (size))
  261.     (%stack-block ((type-ptr 4)
  262.                    (size-ptr 4))
  263.       (ae-error (#_AESizeOfAttribute aevent attr-key type-ptr size-ptr))
  264.       (setf type (%get-ostype type-ptr))
  265.       (setf size (%get-unsigned-long size-ptr)))
  266.     (case type
  267.       (#.#$typeAEList
  268.        (with-aedescs (the-aelist)
  269.          (ae-error (#_AEGetAttributeDesc aevent attr-key #$typeAEList the-aelist))
  270.          (aelist->lisp the-aelist)))
  271.       (#.#$typeAERecord
  272.        (with-aedescs (the-aerecord)
  273.          (ae-error (#_AEGetAttributeDesc aevent attr-key #$typeAERecord the-aerecord))
  274.          (aerecord->lisp the-aerecord)))
  275.       (t
  276.        (%stack-block ((data size)
  277.                       (actual-type 4)
  278.                       (actual-size 4))
  279.          (ae-error (#_AEGetAttributePtr aevent attr-key desired-type actual-type data size actual-size))
  280.          (type&pointer->lisp type data (%get-long actual-size)))))))
  281.  
  282. (defun get-appleevent-attribute-aedesc (aevent attr-key desired-type aedesc)
  283.   (ae-error (#_AEGetAttributeDesc aevent attr-key desired-type aedesc)))
  284.  
  285. (defun put-appleevent-attribute (aevent attr-key data)
  286.   (if (macptrp data) ;;If macptr, assume it is a descriptor
  287.     (ae-error (#_AEPutAttributeDesc aevent attr-key data))
  288.     (with-aedescs (aedesc)
  289.       (lisp->aedesc data aedesc)
  290.       (ae-error (#_AEPutAttributeDesc aevent attr-key aedesc)))))
  291.  
  292. (defun get-appleevent-parameter (aevent param-key desired-type)
  293.   (let ((type)
  294.         (size))
  295.     (%stack-block ((type-ptr 4)
  296.                    (size-ptr 4))
  297.       (ae-error (#_AESizeOfParam aevent param-key type-ptr size-ptr))
  298.       (setf type (%get-ostype type-ptr))
  299.       (setf size (%get-unsigned-long size-ptr)))
  300.     (case type
  301.       (#.#$typeAEList
  302.        (with-aedescs (the-aelist)
  303.          (ae-error (#_AEGetParamDesc aevent param-key #$typeAEList the-aelist))
  304.          (aelist->lisp the-aelist)))
  305.       (#.#$typeAERecord
  306.        (with-aedescs (the-aerecord)
  307.          (ae-error (#_AEGetParamDesc aevent param-key #$typeAERecord the-aerecord))
  308.          (aerecord->lisp the-aerecord)))
  309.       (t
  310.        (%stack-block ((data size)
  311.                       (actual-type 4)
  312.                       (actual-size 4))
  313.          (ae-error (#_AEGetParamPtr aevent param-key desired-type actual-type data size actual-size))
  314.          (type&pointer->lisp type data (%get-long actual-size)))))))
  315.  
  316. (defun get-appleevent-parameter-aedesc (aevent param-key desired-type aedesc)
  317.   (ae-error (#_AEGetParamDesc aevent param-key desired-type aedesc)))
  318.  
  319. (defun put-appleevent-parameter (aevent param-key data)
  320.   (if (macptrp data) ;;If macptr, assume it is a descriptor
  321.     (ae-error (#_AEPutParamDesc aevent param-key data))
  322.     (with-aedescs (aedesc)
  323.       (lisp->aedesc data aedesc)
  324.       (ae-error (#_AEPutParamDesc aevent param-key aedesc)))))
  325.  
  326. (defun put-appleevent-optional-parameter (aevent param-key data)
  327.   (put-appleevent-parameter aevent param-key data)
  328.   (let ((*collapse-primitive-descriptors* nil)
  329.         (optional-params))
  330.     (declare (ignore-if-unused *collapse-primitive-descriptors*))
  331.     (setf optional-params
  332.           (rest
  333.            (ignore-errors
  334.             (get-appleevent-attribute aevent #$keyOptionalKeywordAttr #$typeAEList))))
  335.     (unless (find param-key optional-params :key #'third)
  336.       (put-appleevent-attribute aevent #$keyOptionalKeywordAttr
  337.                                 `(:aelist (:aedesc ,#$typeKeyword ,param-key) ,@optional-params)))))
  338.  
  339. ;; Translate a LISP descriptor into an :aedesc record
  340. ;;
  341. ;;(lisp->aedesc <ldisc> aedesc)
  342. ;;
  343. ;;   <ldesc> :- data     ;;strings, symbols, integers, floats, pathnames
  344. ;;        (:aedesc desctype <ldesc>)
  345. ;;        (:aedesc desctype <macptr>)  ;;zone ptr only
  346. ;;        (:aedesc desctype <macptr> <size>)
  347. ;;        (:aelist <desc>*)
  348. ;;        (:aerecord {<key> <desc>}*)
  349. ;;        (:aedataaray (type size {<common> <size>}) <macptr> <size>)
  350. ;;        (:aepackedarray (type size {<common> <size>}) <macptr> <size>)
  351. ;;        ;no;;(:aehandlearray type <handles> size)
  352. ;;        ;NO;;(:aedescarray <macptr> <size>)
  353. ;;        ;NO;;(:aekeydescarray <macptr> <size>)
  354. ;;              (:aeobject <desired-class> <container> <keyform> <keydata>)
  355.  
  356. (defmethod lisp->aedesc ((integer integer) descriptor)
  357.   (%stack-block ((int-ptr 4))
  358.     (%put-long int-ptr integer)
  359.     (ae-error (#_AECreateDesc #$typeInteger int-ptr 4 descriptor))
  360.     descriptor))
  361.  
  362. (defmethod lisp->aedesc ((string string) descriptor)
  363.   (with-cstrs ((cstring string))
  364.     (ae-error (#_AECreateDesc #$typeChar cstring (length string) descriptor))
  365.     descriptor))
  366.  
  367. (defmethod lisp->aedesc ((symbol symbol) descriptor)
  368.   (lisp->aedesc (symbol-name symbol) descriptor))
  369.  
  370. (defmethod lisp->aedesc ((char character) descriptor)
  371.   (lisp->aedesc (string char) descriptor))
  372.  
  373. (defmethod lisp->aedesc ((float float) descriptor)
  374.   (let ((float-string (format nil "~f" float)))
  375.     (lisp->aedesc `(:aedesc ,#$TypeFloat ,float-string) descriptor)))
  376.  
  377. (defmethod lisp->aedesc ((pathname pathname) descriptor)
  378.   (let ((fsspec (make-record (:fsspec :storage :pointer))))
  379.     ;;fsmakefsspec doesn't seem to like stack allocated blocks
  380.     (unwind-protect
  381.       (lisp->aedesc `(:aedesc ,#$typeFSS ,(pathname->fsspec pathname fsspec) (record-size fssspec))
  382.                     descriptor)
  383.       (dispose-record fsspec))))
  384.  
  385. (defun pathname->fsspec (pathname fsspec)
  386.   ;; NB: this will only work on full pathnames
  387.   (let ((namestring 
  388.          (namestring
  389.           (translate-logical-pathname 
  390.            (merge-pathnames pathname (user-homedir-pathname))))))
  391.     (with-returned-pstrs ((pname namestring))
  392.       (#_FSMakeFSSpec 0 0
  393.        pname
  394.        fsspec)))
  395.   fsspec)
  396.  
  397. (defmethod lisp->aedesc ((list list) descriptor)
  398.   (ecase (first list)
  399.     (:aedesc
  400.      (let ((desctype (second list))
  401.            (data     (third  list)))
  402.        (if (macptrp data)
  403.          (let ((size (or (fourth list) (pointer-size data))))
  404.            (ae-error (#_AECreateDesc desctype data size descriptor)))
  405.          (list->aedesc-by-type desctype data descriptor))))
  406.     
  407.     (:aelist
  408.      (list->aelist (rest list) descriptor))
  409.     
  410.     (:aerecord
  411.      (list->aerecord (rest list) descriptor))
  412.     
  413.     (:aedataarray 
  414.      (let* ((factor (second list))
  415.             (data   (third list))
  416.             (size   (or (fourth list) (pointer-size data))))
  417.        (list->aedataarray factor data size descriptor)))
  418.     
  419.     (:aepackedarray
  420.      (let* ((factor (second list))
  421.             (data   (third list))
  422.             (size   (or (fourth list) (pointer-size data))))
  423.        (list->aepackedarray factor data size descriptor)))
  424.     
  425.     ;(:aehandlearray
  426.     ; (let* ((type   (second list))
  427.     ;        (data   (third list))
  428.     ;        (size   (or (fourth list) (pointer-size data))))
  429.     ;   (list->aeHandlearray type data size descriptor)))
  430.     ;
  431.     ;(:aedescarray
  432.     ; (let* ((data   (second list))
  433.     ;        (size   (or (third list) (pointer-size data))))
  434.     ;   (list->aedescarray data size descriptor)))
  435.     
  436.     (:aeobject
  437.      (let ((desired-class (second list))
  438.            (container     (third list))
  439.            (keyform       (fourth list))
  440.            (keydata       (fifth list)))
  441.        (lisp->aedesc
  442.         `(:aedesc :|obj |
  443.                   (:aerecord
  444.                    :|want| (:aedesc ,#$typeType ,desired-class)
  445.                    :|from| ,container
  446.                    :|form| (:aedesc ,#$typeEnumerated ,keyform)
  447.                    :|seld| ,keydata))
  448.         descriptor)))
  449.     ))
  450.  
  451. ;;
  452. ;; We are given type and data from the list (:aedesc <type> <data>)
  453. ;; If <data> is compatible with <type> we pack the descriptor,
  454. ;; if not, we try to coerce.
  455. ;;;
  456. (defmethod list->aedesc-by-type ((desctype t) data descriptor)
  457.   (with-aedescs (temp)    ;assume coercion
  458.     (lisp->aedesc data temp)
  459.     (ae-error (#_AECoerceDesc temp desctype descriptor)))
  460.   descriptor)
  461.  
  462. (defmethod list->aedesc-by-type ((desctype (eql #$typeBoolean)) data descriptor)
  463.   (case data
  464.     ((t nil)
  465.      (%stack-block ((bool-ptr 1))
  466.        (%put-byte bool-ptr (if data -1 0))
  467.        (ae-error (#_AECreateDesc desctype bool-ptr 1 descriptor)))
  468.      descriptor)
  469.     (otherwise (call-next-method))))
  470.  
  471. (defmethod list->aedesc-by-type ((desctype (eql #$typeNull)) data descriptor)
  472.   (declare (ignore data))
  473.   (ae-error (#_AECreateDesc desctype (%null-ptr) 0 descriptor))
  474.   descriptor)
  475.  
  476. (defmethod list->aedesc-by-type ((desctype (eql #$typeTrue)) data descriptor)
  477.   (declare (ignore data))
  478.   (ae-error (#_AECreateDesc desctype (%null-ptr) 0 descriptor))
  479.   descriptor)
  480.  
  481. (defmethod list->aedesc-by-type ((desctype (eql #$typeFalse)) data descriptor)
  482.   (declare (ignore data))
  483.   (ae-error (#_AECreateDesc desctype (%null-ptr) 0 descriptor))
  484.   descriptor)
  485.  
  486. ;; If data is not a keyword then coerce 
  487. ;; (System 7.0.1 doesn't know how to coerce ostypes... oh well)
  488.  
  489. #+clicc (defvar *keyword-package* (find-package "KEYWORD"))
  490.  
  491. #+clicc (defun keywordp (thing)
  492.           (and (symbol-p thing)
  493.                (eql (symbol-package thing) *keyword-package*)))
  494.  
  495. (defun keyword->aedesc-by-type (desctype keyword descriptor)
  496.   (%stack-block ((keyword-ptr 4))
  497.     (%put-ostype keyword-ptr keyword)
  498.     (ae-error (#_AECreateDesc desctype keyword-ptr 4 descriptor)))
  499.   descriptor)
  500.  
  501. (defmethod list->aedesc-by-type ((desctype (eql #$typeEnumerated)) data descriptor)
  502.   (if (keywordp data)
  503.     (keyword->aedesc-by-type desctype data descriptor)
  504.     (call-next-method)))
  505.  
  506. (defmethod list->aedesc-by-type ((desctype (eql #$typeKeyword)) data descriptor)
  507.   (if (keywordp data)
  508.     (keyword->aedesc-by-type desctype data descriptor)
  509.     (call-next-method)))
  510.  
  511. (defmethod list->aedesc-by-type ((desctype (eql #$typeProperty)) data descriptor)
  512.   (if (keywordp data)
  513.     (keyword->aedesc-by-type desctype data descriptor)
  514.     (call-next-method)))
  515.  
  516. (defmethod list->aedesc-by-type ((desctype (eql #$typeType)) data descriptor)
  517.   (if (keywordp data)
  518.     (keyword->aedesc-by-type desctype data descriptor)
  519.     (call-next-method)))
  520.  
  521. ;; Process address types
  522. (defmethod list->aedesc-by-type ((desctype (eql #$typeApplSignature)) data descriptor)
  523.   (if (keywordp data)
  524.     (keyword->aedesc-by-type desctype data descriptor)
  525.     (call-next-method)))
  526.  
  527. ;;; Alias records 
  528. (defmethod list->aedesc-by-type ((desctype (eql #$typeAlias)) data descriptor)
  529.   (if (pathnamep data)
  530.     (let ((alias (pathname->alias-handle data)))
  531.       (unwind-protect
  532.         (with-dereferenced-handles ((alias-pointer alias))
  533.           (lisp->aedesc `(:aedesc ,#$typeAlias ,alias-pointer ,(pointer-size alias)) descriptor))
  534.         (dispose-record alias))
  535.       descriptor)
  536.     (call-next-method)))
  537.  
  538. (defun pathname->alias-handle (pathname)
  539.   (let ((fsspec (make-record (:fsspec :storage :pointer))))
  540.     ;;fsmakefsspec doesn't like stack allocated blocks (what a mess!!)
  541.     (unwind-protect
  542.       (progn
  543.         (pathname->fsspec (pathname pathname) fsspec)
  544.         (%stack-block ((aliashandle 4))
  545.           (#_NewAlias (%null-ptr) fsspec aliashandle)
  546.           (%get-ptr aliashandle)))
  547.       (dispose-record fsspec))))
  548.  
  549.  
  550. ;;
  551. ;; descriptor lists and keyword lists
  552. ;;
  553. (defun list->aelist (list descriptor)
  554.   (ae-error (#_AECreateList (%null-ptr) 0 nil descriptor))
  555.   (dolist (var list descriptor)
  556.     (with-aedescs (one-aedesc)
  557.       (lisp->aedesc var one-aedesc)
  558.       (ae-error (#_AEPutDesc descriptor 0 one-aedesc)))))
  559.  
  560. (defun list->aerecord (list descriptor)
  561.   (ae-error (#_AECreateList (%null-ptr) 0 t descriptor))
  562.   (do ((key (first list) (first list))
  563.        (contents (second list) (second list)))
  564.       ((null list) descriptor)
  565.     (setf list (cddr list))
  566.     (with-aedescs (contents-descriptor)
  567.       (lisp->aedesc contents contents-descriptor)
  568.       (ae-error (#_AEPutKeyDesc descriptor key contents-descriptor)))))
  569.  
  570. (defun list->aedataarray (factoring-info data data-size descriptor)
  571.   (let* ((item-type (first factoring-info))
  572.          (item-size (second factoring-info))
  573.          (common-info (third factoring-info))
  574.          (common-info-size (when (macptrp common-info)
  575.                              (or (fourth factoring-info) (pointer-size common-info))))
  576.          (size 8))
  577.     (when (macptrp common-info)
  578.       (incf size common-info-size))
  579.     (%stack-block ((pointer size))
  580.       ;; Initialize factoring record for AEPutArray to work?
  581.       (%put-ostype pointer item-type)
  582.       (%put-long pointer item-size 4)
  583.       (when (macptrp common-info)
  584.         (#_BlockMove common-info
  585.          (%int-to-ptr (+ 8 (%ptr-to-int pointer)))
  586.          common-info-size))
  587.       ;;
  588.       (ae-error (#_AECreateList pointer size nil descriptor))
  589.       (ae-error (#_AEPutArray descriptor #$kAEDataArray
  590.                  data item-type item-size
  591.                  (/ data-size (+ item-size (- size 8)))))))
  592.   descriptor)
  593.  
  594. (defun list->aepackedarray (factoring-info data data-size descriptor)
  595.   (let* ((item-type (first factoring-info))
  596.          (item-size (second factoring-info))
  597.          (common-info (third factoring-info))
  598.          (common-info-size (when (macptrp common-info)
  599.                              (or (fourth factoring-info) (pointer-size common-info))))
  600.          (size 8))
  601.     (when (macptrp common-info)
  602.       (incf size common-info-size))
  603.     (%stack-block ((pointer size))
  604.       ;; Initialize factoring record for AEPutArray to work?
  605.       (%put-ostype pointer item-type)
  606.       (%put-long pointer item-size 4)
  607.       (when (macptrp common-info)
  608.         (#_BlockMove common-info
  609.          (%int-to-ptr (+ 8 (%ptr-to-int pointer)))
  610.          common-info-size))
  611.       ;;
  612.       (ae-error (#_AECreateList pointer size nil descriptor))
  613.       (ae-error (#_AEPutArray descriptor #$kAEPackedArray
  614.                  data item-type item-size
  615.                  (/ data-size (+ item-size (- size 8)))))))
  616.   descriptor)
  617.  
  618. ;untested
  619. (defun list->aehandlearray (item-type data data-size descriptor)
  620.   (%stack-block ((pointer 4))
  621.     ;; Initialize factoring record for AEPutArray to work
  622.     (%put-ostype pointer item-type)
  623.     (ae-error (#_AECreateList pointer 4 nil descriptor))
  624.     (ae-error (#_AEPutArray descriptor #$kAEHandleArray
  625.                data item-type 0 (/ data-size 4))))
  626.   descriptor)
  627.  
  628. ;;
  629. ;this doesn't work like I'd expected
  630. ;the call to AEPutArray is not ignoring the itemType and itemSize parameters
  631. ;;
  632. (defun list->aedescarray (aedesc-array size descriptor)
  633.   (ae-error (#_AECreateList (%null-ptr) 0 nil descriptor))
  634.   (ae-error (#_AEPutArray descriptor #$kAEDescArray
  635.              aedesc-array #$typeKeyword
  636.              (record-length :aedesc) (/ size (record-length :aedesc))))
  637.   descriptor)
  638.  
  639. ;ditto
  640. (defun list->aekeydescarray (aekeydesc-array size descriptor)
  641.   (ae-error (#_AECreateList (%null-ptr) 0 t descriptor))
  642.   (ae-error (#_AEPutArray descriptor #$kAEKeyDescArray
  643.              aekeydesc-array 0
  644.              (record-length :aekeydesc) (/ size (record-length :aekeydesc))))
  645.   descriptor)
  646.  
  647.  
  648. ;;
  649. ;; converts appleevent descriptor into LISP descriptor
  650. ;;
  651.  
  652. ;; **Warning**
  653. ; If we don't know how to interpret the type, we allocate space
  654. ; from the heap to store the data and return the pointer.
  655. ; The user has to dispose of the pointer themselves.
  656. ;;
  657. (defmethod type&pointer->lisp ((type t) pointer size)
  658.   ;;default, make copy of pointer
  659.   (let* ((pointer-copy (#_NewPtr size)))
  660.     (#_BlockMove pointer pointer-copy size)
  661.     `(:aedesc ,type ,pointer-copy)))
  662.  
  663. (defun construct-primitive-type (type thing)
  664.   (if *collapse-primitive-descriptors*
  665.     thing
  666.     `(:aedesc ,type ,thing)))
  667.  
  668. (defmethod type&pointer->lisp ((type (eql #$typeBoolean)) pointer size)
  669.   (declare (ignore size))
  670.   (construct-primitive-type type (not (zerop (%get-byte pointer)))))
  671.  
  672. (defmethod type&pointer->lisp ((type (eql #$typeChar)) pointer size)
  673.   (%stack-block ((chars (1+ size)))
  674.     (#_BlockMove pointer chars size)
  675.     (%put-byte chars 0 size)
  676.     (construct-primitive-type type (%get-cstring chars))))
  677.  
  678. (defmethod type&pointer->lisp ((type (eql #$typeInteger)) pointer size)
  679.   (declare (ignore size))
  680.   (construct-primitive-type type (%get-long pointer)))
  681.  
  682. (defmethod type&pointer->lisp ((type (eql #$typeShortInteger)) pointer size)
  683.   (declare (ignore size))
  684.   (construct-primitive-type type (%get-word pointer)))
  685.  
  686. (defmethod type&pointer->lisp ((type (eql #$typeFloat)) pointer size)
  687.   (type&sane->lisp type pointer size))
  688.  
  689. (defmethod type&pointer->lisp ((type (eql #$typeShortFloat)) pointer size)
  690.   (type&sane->lisp type pointer size))
  691.  
  692. (defmethod type&pointer->lisp ((type (eql #$typeExtended)) pointer size)
  693.   (type&sane->lisp type pointer size))
  694.  
  695. (defmethod type&pointer->lisp ((type (eql #$typeComp)) pointer size)
  696.   (type&sane->lisp type pointer size))
  697.  
  698. (defun type&sane->lisp (type pointer size)
  699.   (with-aedescs (sane-string-desc)
  700.     (ae-error (#_AECoercePtr type pointer size #$typeChar sane-string-desc))
  701.     (let ((the-handle (rref sane-string-desc :aedesc.dataHandle)))
  702.       (with-dereferenced-handles ((sane-string (rref sane-string-desc :aedesc.dataHandle)))
  703.         (construct-primitive-type
  704.          type
  705.          (read-from-string
  706.           (let ((*collapse-primitive-descriptors* t))
  707.             (type&pointer->lisp #$typeChar sane-string (#_GetHandleSize the-handle)))))))))
  708.  
  709. (defmethod type&pointer->lisp ((type (eql #$typeMagnitude)) pointer size)
  710.   (declare (ignore size))
  711.   (construct-primitive-type type (%get-unsigned-long pointer)))
  712.  
  713. (defmethod type&pointer->lisp ((type (eql #$typeFSS)) pointer size)
  714.   (declare (ignore size))
  715.   (construct-primitive-type type (%path-from-fsspec pointer)))
  716.  
  717. (defmethod type&pointer->lisp ((type (eql #$typeNull)) pointer size)
  718.   (declare (ignore pointer size))
  719.   `(:aedesc ,type))
  720.  
  721. (defmethod type&pointer->lisp ((type (eql #$typeTrue)) pointer size)
  722.   (declare (ignore pointer size))
  723.   `(:aedesc ,type))
  724.  
  725. (defmethod type&pointer->lisp ((type (eql #$typeFalse)) pointer size)
  726.   (declare (ignore pointer size))
  727.   `(:aedesc ,type))
  728.  
  729. (defmethod type&pointer->lisp ((type (eql #$typeEnumerated)) pointer size)
  730.   (declare (ignore size))
  731.   `(:aedesc ,type ,(%get-ostype pointer)))
  732.  
  733. (defmethod type&pointer->lisp ((type (eql #$typeKeyword)) pointer size)
  734.   (declare (ignore size))
  735.   `(:aedesc ,type ,(%get-ostype pointer)))
  736.  
  737. (defmethod type&pointer->lisp ((type (eql #$typeProperty)) pointer size)
  738.   (declare (ignore size))
  739.   `(:aedesc ,type ,(%get-ostype pointer)))
  740.  
  741. (defmethod type&pointer->lisp ((type (eql #$typeType)) pointer size)
  742.   (declare (ignore size))
  743.   `(:aedesc ,type ,(%get-ostype pointer)))
  744.  
  745. (defmethod type&pointer->lisp ((type (eql #$typeApplSignature)) pointer size)
  746.   (declare (ignore size))
  747.   `(:aedesc ,type ,(%get-ostype pointer)))
  748.  
  749. (defun aelist->lisp (the-aelist)
  750.   (%stack-block ((count 4))
  751.     (ae-error (#_AECountItems the-aelist count))
  752.     (let ((items)
  753.           (c (%get-long count)))
  754.       (dotimes (n c `(:aelist ,@items))
  755.         (push (aelist[n]->lisp the-aelist (- c n)) items)))))
  756.  
  757. (defun aelist[n]->lisp (aelist n)
  758.   (let ((type)
  759.         (size))
  760.     (%stack-block ((type-ptr 4)
  761.                    (size-ptr 4))
  762.       (ae-error (#_AESizeOfNthItem aelist n type-ptr size-ptr))
  763.       (setf type (%get-ostype type-ptr))
  764.       (setf size (%get-unsigned-long size-ptr)))
  765.     (case type
  766.       (#.#$typeAEList
  767.        (with-aedescs (another-aelist)
  768.          (%stack-block ((keyw 4))
  769.            (%put-ostype keyw #$typeWildCard)
  770.            (ae-error (#_AEGetNthDesc aelist n #$typeAEList keyw another-aelist))
  771.            (aelist->lisp another-aelist))))
  772.       (#.#$typeAERecord
  773.        (with-aedescs (another-aelist)
  774.          (%stack-block ((keyw 4))
  775.            (%put-ostype keyw #$typeWildCard)
  776.            (ae-error (#_AEGetNthDesc aelist n #$typeAERecord keyw another-aelist))
  777.            (aerecord->lisp another-aelist))))
  778.       (t
  779.        (%stack-block ((data size)
  780.                       (actual-type 4)
  781.                       (actual-size 4)
  782.                       (keyw 4))
  783.          (ae-error (#_AEGetNthPtr aelist n type keyw actual-type data size actual-size))
  784.          (type&pointer->lisp type data (%get-long actual-size)))))))
  785.  
  786. (defun aerecord->lisp (aerecord)
  787.   (%stack-block ((count 4))
  788.     (ae-error (#_AECountItems aerecord count))
  789.     (let ((items)
  790.           (c (%get-long count)))
  791.       (dotimes (n c `(:aerecord ,@items))
  792.         (setf items
  793.               (nconc (aerecord[n]->lisp aerecord (- c n)) items))))))
  794.  
  795. (defun aerecord[n]->lisp (aerecord n)
  796.   (let ((type)
  797.         (size))
  798.     (%stack-block ((type-ptr 4)
  799.                    (size-ptr 4))
  800.       (ae-error (#_AESizeOfNthItem aerecord n type-ptr size-ptr))
  801.       (setf type (%get-ostype type-ptr))
  802.       (setf size (%get-unsigned-long size-ptr)))
  803.     (case type
  804.       (#.#$typeAEList
  805.        (with-aedescs (aelist)
  806.          (%stack-block ((keyw 4))
  807.            (%put-ostype keyw #$typeWildCard)
  808.            (ae-error (#_AEGetNthDesc aerecord n #$typeAEList keyw aelist))
  809.            (list (%get-ostype keyw) (aelist->lisp aelist)))))
  810.       (#.#$typeAERecord
  811.        (with-aedescs (another-aerecord)
  812.          (%stack-block ((keyw 4))
  813.            (%put-ostype keyw #$typeWildCard)
  814.            (ae-error (#_AEGetNthDesc aerecord n #$typeAERecord keyw another-aerecord))
  815.            (list (%get-ostype keyw) (aerecord->lisp another-aerecord)))))
  816.       (t
  817.        (%stack-block ((data size)
  818.                       (actual-type 4)
  819.                       (actual-size 4)
  820.                       (keyw 4))
  821.          (ae-error (#_AEGetNthPtr aerecord n type keyw actual-type data size actual-size))
  822.          (list (%get-ostype keyw) (type&pointer->lisp (%get-ostype actual-type) data (%get-long actual-size))))))))
  823.